home *** CD-ROM | disk | FTP | other *** search
/ Merciful 5 / Merciful - Disc 5.iso / software / p / pcqpascalv1.2d.lha / Examples2 / AClock / AClock.p < prev   
Text File  |  1997-05-06  |  5KB  |  172 lines
  1. Program AClock;
  2.  
  3. {                          AClock V1.2
  4.  
  5.       AClock ist Freeware, es darf kopiert werden solange damit kein
  6.       Geld verdient wird.
  7.       Wenn Teile des Programms in eigene Programme übernommen werden
  8.       muß mein Name und meine Adresse dabeistehen.
  9.  
  10.          Andreas Tetzl
  11.          Liebethaler Str.18
  12.          O-8300 Pirna-Copitz
  13.          
  14.          ( Neue PLZ ab Juli 93: 01796 )
  15. }
  16.  
  17. {$I "Include:Intuition/Intuition.i"}
  18. {$I "Include:Utils/StringLib.i"}
  19. {$I "Include:Graphics/Graphics.i"}
  20. {$I "Include:Graphics/Pens.i"}
  21. {$I "Include:Exec/Ports.i"}
  22. {$I "Include:Exec/Libraries.i"}
  23. {$I "Include:Exec/Memory.i"}
  24. {$I "Include:Exec/Tasks.i"}
  25. {$I "Include:Utils/DateTools.i"}
  26. {$I "Include:Utils/IOUtils.i"}
  27. {$I "Include:Utils/BuildMenu.i"}
  28. {$I "Include:Libraries/DOS.i"}
  29.  
  30. VAR win : WindowPtr;
  31.     Str, Fast, Chip, h, Min, Sec : String;
  32.     i, Len : Integer;
  33.     DD : DateDescription;
  34.     DS : DateStampRec;
  35.     Msg, MsgSend, MsgReceive  : MessagePtr;
  36.     OldPort, NewPort, ReplyPort : MsgPortPtr;
  37.     TopazFont : TextFontPtr;
  38.     
  39.  
  40. Const StdInName  : String = ("CON:0/0/100/30/AClock");
  41.       StdOutName : String = StdInName;
  42.  
  43.       nw : NewWindow=(190,00,400,10,1,1,CLOSEWINDOW_f,
  44.                  WINDOWCLOSE+WINDOWDEPTH+WINDOWDRAG,
  45.                  NIL,NIL,NIL,NIL,NIL,240,100,240,100,WBENCHSCREEN_F);
  46.  
  47.       MyTextAttr : TextAttr = ("topaz.font",8,FS_NORMAL,FPF_ROMFONT);
  48.  
  49. Procedure CleanUp(RC : Integer);
  50. Begin
  51.   If Win<>NIL then Begin
  52.     DetachMenu;
  53.     CloseWindow(Win);
  54.   end;
  55.   If Gfxbase<>NIL then Closelibrary(GfxBase);
  56.   FreeString(Str);
  57.   FreeString(Fast);
  58.   FreeString(Chip);
  59.   If NewPort<>NIL then RemPort(NewPort);
  60.   Dispose(NewPort);
  61.   If RC<>0 then DisplayBeep(NIL);
  62.   Exit(RC);
  63. End;
  64.  
  65. Begin
  66.   { *** Läuft Programm schon ? *** }
  67.   OldPort:=FindPort("AClock Port");
  68.   If OldPort<>NIL then Begin
  69.     { *** Ja, dann Nachricht an Programm schicken das es beenden soll. *** }
  70.     New(ReplyPort);
  71.     ReplyPort^.mp_Node.ln_Pri:=0;
  72.     ReplyPort^.mp_Node.ln_Name:="AClock ReplyPort";
  73.     ReplyPort^.mp_SigTask:=Findtask(NIL);
  74.     AddPort(ReplyPort);
  75.     New(MsgSend);
  76.     MsgSend^.mn_Length:=SizeOf(MessagePtr);
  77.     MsgSend^.mn_Node.ln_Type:=NTMessage;
  78.     MsgSend^.mn_ReplyPort:=ReplyPort;
  79.     PutMsg(OldPort,MsgSend);
  80.     Msg:=WaitPort(ReplyPort);
  81.     RemPort(ReplyPort);
  82.     DisPose(MsgSend);
  83.     Dispose(ReplyPort);
  84.   end else Begin
  85.     { *** Messageport öffnen *** }
  86.     New(NewPort);
  87.     NewPort^.mp_Node.ln_Pri:=0;
  88.     NewPort^.mp_Node.ln_Name:="AClock Port";
  89.     NewPort^.mp_SigTask:=FindTask(NIL);
  90.     AddPort(NewPort);
  91.  
  92.     { *** Speicher für Strings *** }
  93.     Str:=AllocString(40);
  94.     Fast:=AllocString(20);
  95.     Chip:=AllocString(20);
  96.     { *** Window öffnen *** }
  97.     Win:=OpenWindow(Adr(nw));
  98.     If Win=NIL then Cleanup(10);
  99.     { *** Menu anhängen *** }
  100.     InitializeMenu(Win);
  101.     NewMenu("Info                                ");
  102.       NewItem("AClock V1.2  © 1993 by Andreas Tetzl.",'\0');
  103.       NewItem("This Program is Freeware.            ",'\0');
  104.       NewItem("Made for PURITY.                     ",'\0');
  105.     AttachMenu;
  106.     { *** GraphicsLib öffnen *** }
  107.     GfxBase:=OpenLibrary("graphics.library",0);
  108.     If GfxBase=NIL then Cleanup(10);
  109.     { *** Topaz.Font einstellen *** }
  110.     TopazFont:=OpenFont(adr(MyTextAttr));
  111.     If TopazFont=NIL then Cleanup(10);
  112.     SetFont(Win^.RPort,TopazFont);
  113.     SetAPen(Win^.RPort,2);
  114.     SetBPen(Win^.RPort,1);
  115.     Repeat
  116.       { *** Freies Chipmem ausgeben *** }
  117.       i:=IntToStr(Chip,AvailMem(MEMF_CHIP));
  118.       Len:=StrLen(Chip);
  119.       StrCpy(Str,"CHIP:");
  120.       StrCat(Str,Chip);
  121.       Move(Win^.RPort,31,7);
  122.       GText(Win^.RPort,Str,StrLen(Str));
  123.  
  124.       { *** Freies Fastmem ausgeben ***}
  125.       i:=IntToStr(Fast,AvailMem(MEMF_FAST));
  126.       Len:=StrLen(Fast);
  127.       StrCpy(Str,"FAST:");
  128.       StrCat(Str,Fast);
  129.       Move(Win^.RPort,135,7);
  130.       GText(Win^.RPort,Str,StrLen(Str));
  131.  
  132.       { *** Zeit ausgeben *** }
  133.       DateStamp(DS);
  134.       StampDesc(DS,DD);
  135.       Strcpy(Str,"TIME:");
  136.       If DD.Hour<10 then StrCat(Str,"0");
  137.       i:=IntToStr(h,DD.Hour);
  138.       If StrLen(h)>2 then StrnCpy(h,h,2);   { <- Bei mir hatte DD.Hour manchmal
  139.                                                  3 oder 4 Stellen, und die Depth-
  140.                                                  Gadgets wurden übermalt. Genauso
  141.                                                  ist das mit DD.Minute u. DD.Second.
  142.                                                  Deshalb habe ich das eingebaut.}
  143.       StrCat(Str,h);
  144.       StrCat(Str,":");
  145.       If DD.Minute<10 then StrCat(Str,"0");
  146.       i:=IntToStr(min,DD.Minute);
  147.       If StrLen(min) > 2 then StrnCpy(min,min,2);
  148.       StrCat(Str,min);
  149.       StrCat(Str,":");
  150.       If DD.Second<10 then StrCat(Str,"0");
  151.       i:=IntToStr(sec,DD.Second);
  152.       If StrLen(Sec) > 2 then StrnCpy(Sec,Sec,2);
  153.       StrCat(Str,sec);
  154.       Move(Win^.RPort,239,7);
  155.       GText(Win^.RPort,Str,StrLen(Str));
  156.       Delay(50);
  157.       { *** Programm nochmal gestartet ? *** }
  158.       MsgReceive:=GetMsg(NewPort);
  159.       If MsgReceive<>NIL then begin
  160.         { *** Dann ENDE *** }
  161.         ReplyMsg(MsgReceive);
  162.         Cleanup(0);
  163.       end;
  164.       { *** CloseGadget gedrückt ? *** }
  165.       Msg:=GetMsg(Win^.UserPort);
  166.   Until Msg<>NIL;
  167.   { *** ENDE *** }
  168.   ReplyMsg(Msg);
  169.   Cleanup(0);
  170.   end;
  171. end.
  172.